00200	
00300	(GLOBAL 
00400	  (FUNCTIONS TRY-NEXT NOTE ADIEU AU-REVOIR INSTANCE GET-POSSIBILITIES
00500	   SET-POSSIBILITIES GENERATE)
00600	  (RESERVED *IGNORE *ITEM *NOTE *METHOD *GENERATOR *AU-REVOIR *BLOCK *POSSIBILITI!
00700	ES))
00800	
00900	(DECLARE   (SYMBOLS T) (GENPREFIX \T) (GENSYM 'T) 
01000	 (SPECIAL TEM TEM1 TEM2 ALINK BVARS EXP CLINK FRAME* VAL)
01100	 (*FEXPR CERR INSTANCE PROPOSE /,)
01200	 (*LEXPR CSET VFRAME ACCESS CONTROL))
01300	
01400	(DEFUN ALINK MACRO (L) (LIST 'CDADR (CADR L)))
01500	
01600	(DEFUN CLINK MACRO (L) (LIST 'CDDDR (CADR L)))
01700	
01800	(CDEFUN TRY-NEXT (POSSIBILITIES "OPTIONAL" (NOMORE NIL) (MESSAGE NIL))
01900	   "AUX" (POS)
02000	   (/: TRY-NEXT) (GO (NEXT))
02100	   (/: EXIT) (RETURN (CEVAL NOMORE (ACCESS)))
02200	   (/: RETURN) (RETURN POS)
02300	   (/: *METHOD) (METGO)
02400	   (/: *GENERATOR) (GENGO)
02500	   (/: *AU-REVOIR) (REGO)
02600	   (/: *BLOCK) (TBLOCK))
02700	
02800	(DEFUN NEXT FEXPR (L)
02900	   (SETQ L (/, POSSIBILITIES))
03000	   (COND ((OR (ATOM L) (NOT (EQ (CAAR L) '*POSSIBILITIES)))
03100	          (CERR BAD POSSIBILITIES LIST)))
03200	   (PROG (P)
03300	         (COND ((NULL (CDR L)) (RETURN 'EXIT)))
03400	         (UNBLOCK (CDR L))
03500	    TN   (RPLACD L (CDDR L))
03600	         (COND ((NULL (CDR L)) (RETURN 'EXIT))
03700	               ((EQ (SETQ P (CADR L)) '*IGNORE) (GO TN))
03800	               ((ATOM P) (CSET 'POS P) (RETURN 'RETURN))
03900	               ((EQ (CAR P) '*ITEM)
04000	                (SETUP (CADDR P))
04100	                (CSET 'POS (CADR P))
04200	                (RETURN 'RETURN))
04300	               ((EQ (CAR P) '*NOTE)
04400	                (SETUP (CADR P))
04500	                (CSET 'POS P)
04600	                (RETURN 'RETURN))
04700	               ((MEMQ (CAR P) '(*METHOD *GENERATOR *AU-REVOIR *BLOCK))
04800	                (RETURN (CAR P)))
04900	               (T (CSET 'POS P) (RETURN 'RETURN)))))
05000	
05100	(DEFUN SETUP (ALIST)
05200	   (SETQ TEM (ACCESS))
05300	   (MAPC '(LAMBDA (PAIR) (CSET (CAR PAIR) (CADR PAIR) TEM)) ALIST))
05400	
05500	(DEFUN GENGO ()
05600	 (SETQ TEM (CDR (IVAL 'POSSIBILITIES ALINK))
05700	       BVARS (LIST (LIST 'NEXT TEM))
05800	       CLINK (FR (TAG 'TRY-NEXT))
05900	       ALINK (ALINK CLINK)
06000	       TEM1 (CADAR TEM)
06100	       FRAME* NIL)
06200	 (RPLACA TEM (LIST '*BLOCK))
06300	 (DISPATCH TEM1 'POPJ () '*TOP))
06400	(DEFPROP GENGO GENGO CINT)
06500	
06600	(DEFUN METGO ()
06700	 (SETQ TEM (CDR (IVAL 'POSSIBILITIES ALINK))
06800	       TEM1 (CADAR TEM)
06900	       BVARS (NCONC (LIST (LIST 'NEXT TEM)
07000	                          (LIST '*BODY (TEXT TEM1))
07100	                          (LIST '*CALLPAT (CADDDR (CDAR TEM)))
07200	                          (LIST '*METHPAT (PATTERN TEM1))
07300	                          (LIST '*CALLALIST (CADDDR (CAR TEM)))
07400	                          (LIST '*METHALIST (CADDAR TEM)))
07500	                    (CADDAR TEM))
07600	       EXP (LIST TEM1 (CADDDR (CDAR TEM)))
07700	       FRAME* NIL
07800	       CLINK (FR (TAG 'TRY-NEXT))
07900	       ALINK (ALINK CLINK))
08000	 (CLOSE)
08100	 (RPLACA TEM (LIST '*BLOCK)) 
08200	 'AUXB)
08300	(DEFPROP METGO METGO CINT)
08400	
08500	(DEFUN REGO ()
08600	 (SETQ TEM (CDR (IVAL 'POSSIBILITIES ALINK))
08700	       VAL (IVAL 'MESSAGE ALINK)
08800	       FRAME* (CADAR TEM))
08900	 (SETCONTROL (VFRAME 'NEXT (CAR TEM)) (TAG 'TRY-NEXT))
09000	 (CSET 'NEXT TEM (CAR TEM))
09100	 (RPLACA TEM (LIST '*BLOCK))
09200	 (RESTORE))
09300	(DEFPROP REGO REGO CINT)
09400	
09500	(CDEFUN TBLOCK ()
09600	  (NCONC (CADR POSSIBILITIES) (TAG 'TRY-NEXT))
09700	  (ALLOW NIL)
09800	  (COND ((/@ . READY) (CONTINUE (/@ PROG2 (ALLOW T) (CAR READY) (SETQ READY (CDR !
09900	READY))))))
10000	  (ALLOW T)
10100	  (LISTEN 'ALL-BLOCKED-UP))
10200	
10300	(DEFUN UNBLOCK (L)
10400	  (COND ((EQ (CAAR L) '*BLOCK)
10500	         (NCONC (GET 'READY 'VALUE) (CDAR L))
10600	         (RPLACA L '*IGNORE))))
10700	
10800	(DEFUN NOTE N
10900	 (COND ((= N 0) 
11000	        ((LAMBDA (P) (COND (P (ENTER P))))
11100	         (INSTANCE))
11200	        0)
11300	       (T (PROG (NEXT M)
11400	                (SETQ M 0 NEXT (CDR (VLOC 'NEXT)))
11500	           LP (COND ((> (SETQ M (ADD1 M)) N) (RETURN N)))
11600	              (RPLACD (CAR NEXT) (CONS (ARG M)(CDAR NEXT)))
11700	              (RPLACA NEXT (CDAR NEXT))
11800	              (GO LP)))))
11900	
12000	(CDEFUN ADIEU ("REST" L) (PROPOSE) (DISMISS (VFRAME 'NEXT)))
12100	
12200	(CDEFUN AU-REVOIR ("REST" L) (PROPOSE) 
12300	   (ENTER (CONS '*AU-REVOIR (CDR (CONTROL))))
12400	   (DISMISS (VFRAME 'NEXT)))
12500	
12600	(DEFUN ENTER (X)
12700	   (SETQ TEM (CDR (VLOC 'NEXT)))
12800	   (RPLACD (CAR TEM) (CONS X (CDAR TEM)))
12900	   (RPLACA TEM (CDAR TEM)))
13000	
13100	(DEFUN PROPOSE FEXPR (L)
13200	   (SETQ L (CDR (VLOC 'NEXT)))
13300	   (MAPC '(LAMBDA (X) 
13400	              (RPLACD (CAR L) (CONS X (CDAR L)))
13500	              (RPLACA L (CDAR L)))
13600	         (/, L)))
13700	
13800	(DEFUN INSTANCE FEXPR (L)
13900	 (PROG (NEXTF CALLA)
14000	   (SETQ NEXTF (FR (VFRAME 'NEXT))
14100	         CALLA (IVAL '*CALLALIST NEXTF)
14200	         L (MATCH (IVAL '*CALLPAT NEXTF)
14300	                    (IVAL '*METHPAT NEXTF)
14400	                    CALLA
14500	                    (IVAL '*METHALIST NEXTF)))
14600	   (COND (L (RETURN (LIST '*NOTE (CPY (CAR L))))))))
14700	
14800	(DEFUN CPY (L) (MAPCAR '(LAMBDA (X) (LIST (CAR X)(CADR X))) L))
14900	
15000	(DEFUN GET-POSSIBILITIES FEXPR () (IVAL 'POSSIBILITIES (CLINK (FR (VFRAME 'NEXT))!
15100	)))
15200	
15300	(DEFUN SET-POSSIBILITIES (LIST) (CSET 'POSSIBILITIES LIST (CONTROL (VFRAME 'NEXT)!
15400	)))
15500	
15600	(CDEFUN GENERATE ('FORM) "AUX" ((POSSIBILITIES
15700	                                  (LIST (LIST '*POSSIBILITIES FORM)
15800	                                        (LIST '*GENERATOR FORM))))
15900	    (GENGO)
16000	  (/: TRY-NEXT)
16100	    POSSIBILITIES)
16200